home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr51
/
lib201.zip
/
FIELDS.PRG
< prev
next >
Wrap
Text File
|
1993-03-24
|
24KB
|
623 lines
*-------------------------------------------------------------------------------
*-- Program...: FIELDS.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 03/24/1993
*-- Notes.....: These field processing routines were deemed as not as commonly
*-- used (at least in my own Applications), and relegated to a
*-- library file. See: README.TXT about how to use this library
*-- file.
*-------------------------------------------------------------------------------
FUNCTION MemoPagr
*-------------------------------------------------------------------------------
*-- Programmer..: Martin Leon (HMAN - ATBBS/Borland BBS)
*-- Date........: 10/28/1991
*-- Notes.......: Used to display a memo on screen, allowing user to scroll
*-- memo at will.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 10/28/1991 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ?MemoPagr(<cMemo>,<ULRow>,<ULCol>,<BRRow>,<BRCol>)
*-- Example.....: ?MemoPagr(MoreData,10,20,20,65)
*-- Returns.....: .F.
*-- Parameters..: cMemo = name of memo field
*-- nULRow = upper left row position
*-- nULCol = upper left column position
*-- nBRRow = bottom right row position
*-- nBRCol = bottom right column position
*-------------------------------------------------------------------------------
PARAMETER cMemo, nULRow, nULCol, nBRRow, nBRCol
private cCursor, nEsc, nPgDn, nPgUp, nUp, nDn, nNumLines,nLines,nKey
private nAtLine,nAtRow
*-- set environment
set memowidth to nBRCol - nULCol - 1
cCursor = set( "CURSOR" )
set cursor off
*-- define a few keys
nEsc = 27
nPgDn = 3
nPgUp = 18
nUp = 5
nDn = 24
*-- determine size of window
nNumLines = memlines(&cMemo)
nLines = nBRRow - nULRow - 1
*-- save the screen, so we can restore it
save screen to sTmp
@ nULRow+1, nULCol+1 clear to nBRRow+1, nBRCol+1
@ nULRow+1, nULCol+1 fill to nBRRow+1, nBRCol+1 color B/N
@ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 color RG+/B
@ nULRow, nULCol to nBRRow, nBRCol double color RG+/B
*-- deal with a blank memo ...
if nNumLines = 0
@ nULRow + 1, nULCol + 1 SAY ;
"Blank Memo. Press any key to continue..." color RG+/B
nKey = inkey(0)
*-- reset the whole thing
restore screen from sTmp
release screen sTmp
set cursor &cCursor
RETURN .F.
endif
nAtLine = 1
nAtRow = 1
do while nAtLine <= nNumLines
*-- Show one window full
do while nAtRow <= nLines .and. nAtLine <= nNumLines
@ nULRow+nAtRow, nULCol + 1 say ;
mline( &cMemo, nAtLine ) color RG+/B
nAtLine = nAtLine + 1
nAtRow = nAtRow + 1
enddo
*-- If at last line of memo...
if nAtLine > nNumLines
*-- If memo is shorter than one page, put box character in
*-- bottom left corner of box, otherwise, put an up arrow
*-- symbol there.
@ nBRRow - 1, nBRCol SAY ;
iif( nNumLines <= nLines, chr(186), chr(24)) color W+/B
do while .T.
nKey = inkey(0)
*-- If memo is shorter than one page, only allow Esc key
if nNumLines <= nLines
if nKey = nEsc
exit
endif
*-- Otherwise, allow Esc or PgUp keys
else
if nKey = nEsc .or. nKey = nPgUp .or. nKey = nUp
exit
endif
endif
?? chr(7)
enddo
if nKey = nEsc
restore screen from sTmp
release screen sTmp
set cursor &cCursor
RETURN .F.
endif
@ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
@ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
color RG+/B
nAtLine = nAtLine - nAtRow - nLines + 1
nAtLine = iif( nAtLine < 1, 1, nAtLine )
nAtRow = 1
loop
endif
*-- Not at end of memo yet...
*-- If on first page, show down arrow only, otherwise show
*-- up/down arrow on border of box.
@ nBRRow - 1, nBRCol say ;
iif( nAtLine - nLines = 1, chr(25), chr(18)) color W+/B
do while .T.
nKey = inkey(0)
*-- If this is the first page of the memo on screen...
if nAtLine - nLines = 1
*-- Only honor PgDn, up cursor, and Esc keys
if nKey = nPgDn .or. nKey = nDn .or. nKey = nEsc
exit
endif
*-- otherwise honor PgUp and up cursor as well key as well
else
if nKey = nPgUp .or. nKey = nUp .or. nKey = nPgDn .or. ;
nKey = nDn .or. nKey = nEsc
exit
endif
endif
?? chr(7)
enddo
do case
case nKey = nEsc
restore screen from sTmp
release screen sTmp
set cursor &cCursor
RETURN .F.
case nKey = nPgUp .or. nKey = nUp
@ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
@ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
color RG+/B
nAtLine = (nAtLine - (2 * nLines))
nAtLine = IIF( nAtLine < 1, 1, nAtLine )
nAtRow = 1
loop
case nKey = nPgDn .or. nKey = nDn
@ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
@ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
color RG+/B
nAtRow = 1
loop
endcase
enddo
RETURN .F.
*-- EoF: MemoPagr()
PROCEDURE ScanMemo
*-------------------------------------------------------------------------------
*-- Programmer..: Martin Leon (HMAN)
*-- Date........: 02/27/1992
*-- Notes.......: This simple procedure is used to strip hard carriage returns
*-- out of all Memos in a database.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/15/1991 - original procedure.
*-- 02/07/1992 -- Douglas P. Saine (XRED) modified to handle
*-- passing of database name as a parameter
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Do ScanMemo with "<cDbf>"
*-- Example.....: Do ScanMemo with "TEST"
*-- Returns.....: None.
*-- Parameters..: cDbf = Name of the database to scan memos ...
*-------------------------------------------------------------------------------
parameter cDbf
private nFields, cFieldName, nLines, nLineNum
use (cDbf)
scan && search database 1 record at a time ...
nFields = 1
*-- This loop goes through all fields in the database
do while asc(field(nFields)) # 0
cFieldName = field(nFields) && save current field name
if type(cFieldName) = "M" && check to see if it's a memo
nLines = memlines(&cFieldName) && number of lines in memo
if nLines > 1 && if there's something there
delete file temp.txt && kill old file if it exists
set printer to file temp.txt && copy memo a line at a time to
nLineNum = 1 && temp file, using ??? command.
do while nLineNum <= nLines
??? mline(&cFieldName,nLineNum)
??? " "
nLineNum = nLineNum + 1
enddo
close printer
set printer to
append memo &cFieldName from temp.txt overwrite
endif && nLines > 1
endif && type(cFieldName) = "M"
nFields = nFields + 1 && go to next field ...
enddo && asc(field....
endscan && scan of database record by record ...
use && close database
RETURN
*-- EoP: ScanMemo
PROCEDURE Cut
*-------------------------------------------------------------------------------
*-- Programmer..: Michael B. Carlisle (Borland)
*-- Date........: 01/01/1992
*-- Notes.......: This retrieves information from the field the user has
*-- currently selected and stores the information into a
*-- memory variable titled CLIPBOARD. The field itself is
*-- then cleared. CLIPBOARD should be declared public.
*-- This routine is taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 01/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do CUT with "<cFld>","<cScrType>"
*-- Example.....: on key label F6 do CUT with varread(),"READ"
*-- Returns.....: None
*-- Parameters..: cFld = Field to 'CUT' the data from.
*-- cScrType = What screen type? Valid options are BROWSE,
*-- EDIT and READ.
*-------------------------------------------------------------------------------
parameters cFld,cScrType
*-- test field type, ignore if field is memo
clipboard = iif(type(cFld) = "D",;
right(dtos(&cFld),4)+substr(dtos(&cFld),3,2),;
iif(type(cFld) = "L",iif(&cFld,"T","F"),;
iif(type(cFld)="M","",&cFld)))
*-- if field type is Numeric or Float, convert to string.
if type(cFld) $ "NF"
clipboard = ltrim(str(int(fixed(&cFld)),20)+;
right(str(fixed(&cFld) - int(fixed(&cFld)),20,18,19))
do while val(right(clipboard,1)) = 0 .and. .not. right(clipboard,1)="."
clipboard = left(clipboard,len(clipboard)-1)
enddo
endif
*-- Ring bell if field is MEMO, otherwise, clear the field
if type(cFld) = "M"
?? chr(7)
else
*-- do to difference in function of the HOME keys in BROWSE mode,
*-- Ctrl-Home has to be used in BROWSE
if upper(cScrType) = "BROWS"
keyboard chr(29)+chr(25) && go to beginning of field and clear
else
keyboard chr(26)+chr(25) && ditto
endif
endif
RETURN
*-- EoP: Cut
PROCEDURE Copy
*-------------------------------------------------------------------------------
*-- Programmer..: Michael B. Carlisle (Borland)
*-- Date........: 01/01/1992
*-- Notes.......: This retrieves information from the field the user has
*-- currently selected and stores the information into a
*-- memory variable titled CLIPBOARD. The field itself is
*-- left 'as is' (unlike CUT). CLIPBOARD should be declared
*-- public. This routine is taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 01/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do COPY with "<cFld>"
*-- Example.....: on key label F8 do COPY with varread()
*-- Returns.....: None
*-- Parameters..: cFld = Field to 'COPY' the data from.
*-------------------------------------------------------------------------------
parameters cFld
*-- test field type, ignore if field is memo
clipboard = iif(type(cFld) = "D",;
right(dtos(&cFld),4)+substr(dtos(&cFld),3,2),;
iif(type(cFld) = "L",iif(&cFld,"T","F"),;
iif(type(cFld)="M","",&cFld)))
*-- if field type is Numeric or Float, convert to string.
if type(cFld) $ "NF"
clipboard = ltrim(str(int(fixed(&cFld)),20)+;
right(str(fixed(&cFld) - int(fixed(&cFld)),20,18,19))
do while val(right(clipboard,1)) = 0 .and. .not. right(clipboard,1)="."
clipboard = left(clipboard,len(clipboard)-1)
enddo
endif
*-- Ring bell if field is MEMO, otherwise, clear the field
if type(cFld) = "M"
?? chr(7)
endif
RETURN
*-- EoP: Copy
PROCEDURE Paste
*-------------------------------------------------------------------------------
*-- Programmer..: Michael B. Carlisle (Borland)
*-- Date........: 01/01/1992
*-- Notes.......: Paste writes out the contents of the CLIPBOARD (public)
*-- memvar to the currently selected field. Because all values
*-- are converted to strings when stored into the CLIPBOARD,
*-- Paste is able to write values from one field type to another
*-- (such as numeric to character, date to numeric, etc.).
*-- This routine is taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 01/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do PASTE with "<cFld>","<cScrType>"
*-- Example.....: on key label F7 do PASTE with varread(), "READ"
*-- Returns.....: None
*-- Parameters..: cFld = Field to 'PASTE' the data in CLIPBOARD to.
*-- cScrType = What screen type? Valid options are BROWSE,
*-- EDIT and READ.
*-------------------------------------------------------------------------------
parameters cFld, cScrType
*-- ring bell if field is MEMO, otherwise, fill the field.
if type(cFld) = "M"
?? chr(7)
else
*-- due to difference in function of HOME in the BROWSE mode,
*-- Ctrl-Home has to be used in BROWSE.
if upper(cScrType) = "BROWSE"
keyboard chr(29)+chr(25)+ClipBoard && go to beginning of field,
&& and clear, putting contents
&& of clipboard in.
else
keyboard chr(26)+chr(25)+ClipBoard
endif
endif && type ...
RETURN
*-- EoP: Paste
FUNCTION Blanker
*-------------------------------------------------------------------------------
*-- Programmer..: Curt Schroeders (Borland Tech Support)
*-- Date........: 07/01/1992
*-- Notes.......: Used to BLANK a numeric field once the user presses a key
*-- that may be used IN a numeric field.
*-- SIDE EFFECT -- if you use this function, the original value
*-- in the field will be erased ... this does not allow editing
*-- of the numeric field.
*-- Written for.: dBASE IV, 1.5 (should work in 1.1)
*-- Rev. History: 07/01/1992 -- Original
*-- 07/13/1992 -- Ken Mayer -- added '-' and '.' as valid
*-- characters in list ...
*-- Usage.......: Blanker()
*-- Example.....: @5,10 get Salary when blanker()
*-- Returns.....: Logical
*-- Parameters..: None
*-------------------------------------------------------------------------------
private nX
*-- get keystroke from user
nX = inkey(0)
*-- if nX is in list
if chr(nX) $ "0123456789-."
keyboard "{CTRL-Y}" && blank out field
endif
keyboard chr(nX) && return this character ...
RETURN .t.
*-- EoF: Blanker()
FUNCTION GetRange
*-------------------------------------------------------------------------------
*-- Programmer..: Joey D. Carroll (JOEY)
*-- Date........: 10/12/1992
*-- Notes.......: A function to get a range for use with 'set key to range x,y'
*-- or 'set filter to'. Works with character, numeric, float,
*-- and date types.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 11/08/1992 Changed to protect active windows.
*-- Added SHADOW (JOEY)
*-- 11/09/1992 Added (optional) cStyle parameter (JOEY)
*-- Calls.......: CENTER Procedure in PROC.PRG
*-- SHADOW Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: ?? GetRange(<cText>,<xPara1>,<xPara2>,<cPicture>, ;
*-- <nStartRow>,<cColor>[,cStyle])
*-- Example.....: * get a range for a date, dbf in use is ordered by TRANDATE
*-- dDate1={}
*-- dDate2={}
*-- ?? GetRange("Enter date range for your report",dDate1,dDate2,;
*-- "",10,"w+/r,n/w,w+/gb")
*-- * now use values determined by getrange()
*-- set key to range dDate1,dDate2
*-- go top
*-- * if the dbf is not indexed on a date or if you just =have=
*-- * to use a filter e.g.--
*-- * set filter to Transdate >= dDate1 .and. Transdate<=dDate2
*-- report form <yourreport> to print
*-- Returns.....: .t. if correct type parameters, otherwise .f.
*-- Parameters..: cText = Message to center in window. May be nul "".
*-- xPara1 = First elemement of the 'key'.
*-- The 'width' of the character 'get' is
*-- determined by len(xPara1).
*-- The 'width' of the date 'get' is determined
*-- by set("century").
*-- xPara2 = Second element of the 'key'.
*-- cPicture = Used to determine 'width' and format of
*-- numeric or float 'get', and the format
*-- of the character 'get'. May be nul "".
*-- Ignored if xPara1 is date type.
*-- nStartRow = Row to place top of window.
*-- Message row (24) is protected.
*-- cColor = Colors to be used ("Normal/HiLite/Box")
*-- (may be nul "", in order to use the
*-- default colors of window/screen)
*-- cStyle = "H" = horizontal "V" = verticle (may be
*-- omitted or ""/nul to default to "H" --
*-- =Very= long parameters default to "V")
*-------------------------------------------------------------------------------
parameters cText,xPara1,xPara2,cPicture,nStartRow,cColor,cStyle
private cTalk,cColor2,nSayLen,nPictLen,wPrevWind,nEndRow
*-- is a window active
wPrevWind = window()
activate screen
*-- in case no color is passed, this will prevent bomb
cColor2 = iif(isblank(cColor),"","color &cColor")
*-- calculate window size based on parameters
do case
case type("xPara1") = "C"
*-- xPara1,xPara2 should initialized with space(len(alias->fieldname))
*-- or space(len(var))
nPictLen = 2 * len(xPara1)
case type("xPara1") = "N" .or. type("xPara1") = "F"
*-- gotta have a picture to define window width
cPicture = iif(isblank(cPicture),"9999999999",cPicture)
nPictLen = 2 * len(cPicture)
case type("xPara1")="D"
nPictLen = 2 * (iif(set("CENTURY")="OFF",8,10))
otherwise
if .not. isblank(wPrevWind)
activate window &wPrevWind
endif
?? chr(7)
RETURN .f. && stupid!
endcase
cText = " "+cText && don't jamb against box edge
*-- is the window width going to be wider than 75 cols, OR was "V"
*-- passed in the cStyle param? If so, use verticle style
nSayLen = len("From: ") + len("To: ")
nWindWidth = nSayLen + nPictLen + 7
*-- if len(cText) > nWindWidth, fix it
nWindWidth = max(nWindWidth,len(cText) + 3)
if nWindWidth <= 76 .and. (pcount() < 7 .or. upper(cStyle) = "H")
cStyle = "H" && make it so
nStartRow = min(nStartRow,16) && protect row 24 even from shadow
nStartCol = (80-nWindWidth) / 2 && center the window
nEndRow = nStartRow + 6
define window wGetRange from nStartRow,nStartCol to nEndRow, ;
nStartCol+nWindWidth &cColor2. double
else
*-- wants verticle style or params are too wide for horizontal
*-- so do some re-figgering
cStyle = "V" && make it so
nStartRow = min(nStartRow,14) && protect row 24 even from shadow
nEndRow = nStartRow + 8
*-- recalc window width for this style
nSayLen = len("From: ")
nPictLen = nPictLen / 2 && doubled for horz., so cut by 1/2
nWindWidth = nSayLen + nPictLen + 7
*-- if len(cText) > nWindWidth, fix it
nWindWidth = max(nWindWidth,len(cText) + 3)
nStartCol = (80-nWindWidth) / 2 && center the window
define window wGetRange from nStartRow,nStartCol to nEndRow, ;
nStartCol+nWindWidth &cColor2. double
endif
save screen to sGetRange
*-- now USE what you've done so far
do shadow with nStartRow,nStartCol,nEndRow,nStartCol+nWindWidth
activate window wGetRange
do center with 1,nWindWidth - 2,"",cText
@ 2,0 to 2,nWindWidth - 2
@ 3,2 say 'From:' get xPara1 picture cPicture
if cStyle = "H"
@ 3,(nWindWidth- 2 ) - (len("To: ")) - (nPictLen/2) - 1 ;
say 'To:' get xPara2 picture cPicture
else
@ 5,4 say 'To:' get xPara2 picture cPicture
endif
read
*-- clean up your doin's
deactivate window wGetRange
restore screen from sGetRange
release screen sGetRange
release window wGetRange
if .not. isblank(wPrevWind)
activate window &wPrevWind
endif
RETURN .t.
*-- EoF: GetRange()
FUNCTION FldWidth
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 71542,2712)
*-- Date........: 03/24/1993
*-- Notes.......: Returns the width of a field, without having to read the
*-- .DBF structure into a file and use low-level functions ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/28/1993 -- Original
*-- 03/24/1993 -- Lee Hite -- Enhanced to accept a field name
*-- as well as a field number, also added optional <cAlias>
*-- to allow checking a file that is not currently selected.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: FldWidth(<nField>[,<cAlias>])
*-- Example.....: ?FldWidth(3) or
*-- ?FldWidth("MyField") or
*-- ?FldWidth("MyField","MyFile")
*-- Returns.....: Numeric value
*-- Parameters..: nField = field number (or name) in file structure
*-- cAlias = Optional file alias (defaults to current)
*-------------------------------------------------------------------------------
parameters nField, cAlias
private nReturn, cFldType, cFldName, cDBF
*-- Deal with alias passed as a parameter
cDBF = iif(type("CALIAS") = "L",alias(),cAlias)
*-- deal with field parameter being numeric or character
cFldName = iif(type("nField") = "N",field(nField,cDBF),nField)
*-- readyt to go ...
cFldType = type("&cDBF.->&cFldName.") && get the type ...
do case
case cFldType = "L"
nReturn = 1
case cFldType = "D"
nReturn = 8
case cFldType = "C"
nReturn = len(&cDBF.->&cFldName.)
case cFldType $ "NF"
nReturn = len(transform(&cDBF.->&cFldName.,"@L"))
otherwise
nReturn = 0
endcase
RETURN nReturn
*-- EoF: FldWidth()
FUNCTION FldDec
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 71542,2712)
*-- Date........: 01/28/1993
*-- Notes.......: Returns the number of decimal places of a numeric field.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/28/1993 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: FldDec(<nField>)
*-- Example.....: ?FldDec(3)
*-- Returns.....: Numeric value, 0 if non-numeric field type
*-- Parameters..: nField = field number in file structure
*-------------------------------------------------------------------------------
parameters nField
private nReturn, cTemplate, cFldName
cFldName = field(nField)
if type(cFldName) $ "NF" && if it's numeric/float type
cTemplate = transform(&cFldName.,"@L")
nReturn = at(".",cTemplate)
if nReturn > 0
nReturn = len(cTemplate) - nReturn
endif
else
nReturn = 0
endif
RETURN nReturn
*-- EoF: FldDec()
*-------------------------------------------------------------------------------
*-- EoP: FIELDS.PRG
*-------------------------------------------------------------------------------